home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / GRAPHICS / GIF / GIFIMG.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-13  |  36KB  |  1,002 lines

  1. {+--------------------------------------------------------------------------+
  2.  | Component: TGifImage & TGif
  3.  | Created: 4/12/96 11:52:35 PM
  4.  | Author: Jeff Kinzer
  5.  | Copyright 1996, all rights reserved.
  6.  | Description: Displays / Converts GIF Files
  7.  | Version: 1.0
  8.  | Revision: 0.1
  9.  | History:
  10.  |    * Borland Pascal      -  GifUtl.pas     Sean Wenzel       ( CompuServe: 71736,1245 )
  11.  |    * Converted to Delphi -  Gif2Bmp.pas    Richard Dominelli ( CompuServe: 73541,2555 )
  12.  |    * Created TGifImage   -  GifImg.pas     Jeff Kinzer       ( CompuServe: 102413,3557 )
  13.  | Unsupported GIF Features:
  14.  |    * Misc. Extension Blocks:
  15.  |        + Graphic Control extension
  16.  |        + Comment extension
  17.  |        + Plain text extension
  18.  |        + Application extension
  19.  | Note: I'm not sure what will happen if these
  20.  |       blocks are encountered but it'll be interesting
  21.  +--------------------------------------------------------------------------+}
  22.  
  23. unit GifImg;
  24.  
  25. interface
  26.  
  27. uses
  28.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  29.   ExtCtrls, StdCtrls, Menus;
  30.  
  31. const
  32. { General Purpose Constants }
  33.     MAXSCREENWIDTH = 800;
  34.     MAXCODES = 4095;                                { the maximum number of different codes 0 inclusive }
  35.  
  36. type
  37.   TGifStatus = 0..100;
  38.  
  39.   TStatusChangeEvent = procedure(Sender: TObject; Status: TGifStatus) of object;
  40.  
  41.   PGifDataSubBlock = ^TGifDataSubBlock;
  42.     TGifDataSubBlock = record
  43.         Size: Byte;                                   { Size of the block -- 0 to 255 }
  44.         Data: array[1..255] of Byte;                  { The data }
  45.     end;
  46.  
  47.   PGifHeader = ^TGifHeader;
  48.     TGifHeader = record
  49.         Signature: array[0..2] of Char;               { Contains 'GIF' }
  50.         Version: array[0..2] of Char;                 { '87a' or '89a' }
  51.     end;
  52.  
  53.   TLogicalScreenDescriptor = record
  54.     ScreenWidth: Word;                            { Logical screen width }
  55.     ScreenHeight: Word;                           { Logical screen height }
  56.     PackedFields: Byte;                           { Packed fields (See Below) }
  57.     BackGroundColorIndex: Byte;                   { Index to global color table }
  58.     AspectRatio: Byte;                            { Actual ratio = (AspectRatio + 15) / 64 }
  59.   end;
  60.  
  61.     TColorItem = record                                    { One item color table }
  62.         Red: Byte;
  63.         Green: Byte;
  64.         Blue: Byte;
  65.     end;
  66.  
  67.   TColorTable = array[0..255] of TColorItem;          { The color table }
  68.  
  69.     TGifImageDescriptor = record
  70.         Separator: Byte;                          { Fixed value of ImageSeparator }
  71.         ImageLeftPos: Word;                     { Column in respect to left edge of logical screen }
  72.     ImageTopPos: Word;                      { Row in respect to top of logical screen }
  73.         ImageWidth: Word;                          { Width of image in pixels }
  74.         ImageHeight: Word;                       { Height of image in pixels }
  75.         PackedFields: Byte;                      { See below }
  76.     end;
  77.  
  78. (*
  79.     TExtensionBlock = record
  80.         Introducer: Byte;                               { Fixed value of ExtensionIntroducer }
  81.         ExtensionLabel: Byte;
  82.         BlockSize: Byte;
  83.   end;
  84.  
  85.     PGifCodeItem = ^TGifCodeItem;
  86.   TGifCodeItem = record
  87.         Code1,
  88.     Code2: Byte;
  89.   end;
  90. *)
  91.  
  92.     TGraphicLine = array [0..2048] of Byte;
  93.  
  94.   TGifVersion = (v87a, v89a);
  95.  
  96.     PGif = ^TGif;
  97.     TGif = class(TGraphic)
  98.   private
  99.     FGifVersion: TGifVersion;
  100.     FOnChange: TNotifyEvent;
  101.     FOnStatusChange: TStatusChangeEvent;
  102.     FBitmap: TBitmap;
  103.         FInterlaced: Boolean;                                { true if image is interlaced }
  104.     { GIF Data }
  105.         GifStream: TMemoryStream;                      { the file stream for the gif file }
  106.         Header: TGifHeader;                                { gif file header }
  107.         LogicalScreen: TLogicalScreenDescriptor;    { gif screen descriptor }
  108.         GlobalColorTable: TColorTable;                  { global color table }
  109.         LocalColorTable: TColorTable;                      { local color table }
  110.         ImageDescriptor: TGifImageDescriptor;             { image descriptor }
  111.         UseLocalColors: Boolean;                        { true if local colors in use }
  112.         LZWCodeSize: Byte;                                  { minimum size of the LZW codes in bits }
  113.         ImageData: TGifDataSubBlock;                        { variable to store incoming gif data }
  114.         TableSize: Word;                                      { number of entrys in the color table }
  115.         BitsLeft,                                   { bits left in Byte  }
  116.     BytesLeft: Integer;                            { Bytes left in block }
  117.         BadCodeCount: Word;                            { bad code counter }
  118.         CurrCodeSize: Integer;                         { Current size of code in bits }
  119.         ClearCode: Integer;                            { Clear code value }
  120.         EndingCode: Integer;                           { ending code value }
  121.         Slot: Word;                                                { where next new code will be added }
  122.         TopSlot: Word;                                    { highest slot position for the current code size }
  123.         HighCode: Word;                                  { highest code that does not require decoding }
  124.         NextByte: Integer;                            { the index to the next Byte in the datablock array }
  125.         CurrByte: Byte;                                  { the current Byte }
  126.         DecodeStack: array[0..MAXCODES] of Byte;    { stack for the decoded codes }
  127.         Prefix: array[0..MAXCODES] of Integer;      { array for code prefixes }
  128.         Suffix: array[0..MAXCODES] of Integer;      { array for code suffixes }
  129.         LineBuffer: TGraphicLine;                    { array for buffer line output }
  130.         CurrentX,
  131.     CurrentY: Integer;                          { current screen locations }
  132.         InterlacePass: Byte;                        { interlace pass number }
  133.         { Bitmap Data }
  134.         BmHeader: TBitmapInfoHeader;                { File Header for bitmap file }
  135.     BmpStream: TMemoryStream;
  136.         ImageLines: TList;                          { Image data }
  137.     { Status Variables }
  138.     FStatus: TGifStatus;
  139.     CurStatus,
  140.     MaxStatus: Integer;
  141.     FFileName: TFileName;
  142.         { Member Functions }
  143.     procedure GifError(ErrorStr: String);
  144.         procedure Decode;
  145.     procedure GifDecode;
  146.     procedure WriteStream;
  147.     procedure ParseMem;
  148.     procedure SetBitmap(newValue: TBitmap);
  149.     function GetGifVersion: TGifVersion;
  150.     procedure SetGifVersion(newValue: TGifVersion);
  151.     function GetInterlaced: Boolean;
  152.     procedure SetInterlaced(newValue: Boolean);
  153.   protected
  154.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  155.     function GetEmpty: Boolean; override;
  156.     function GetHeight: Integer; override;
  157.     function GetWidth: Integer; override;
  158.     procedure ReadData(Stream: TStream); override;
  159.     procedure SetHeight(Value: Integer); override;
  160.     procedure SetWidth(Value: Integer); override;
  161.     procedure WriteData(Stream: TStream); override;
  162.     procedure ChangeStatus(LoadStatus: LongInt); virtual;
  163.     procedure TriggerChangeEvent; virtual;
  164.   public
  165.         constructor Create;
  166.         destructor Destroy; override;
  167.     procedure Assign(Source: TPersistent); override;
  168.     procedure LoadFromFile(const Filename: string); override;
  169.     procedure SaveToFile(const Filename: string); override;
  170.     procedure LoadFromStream(Stream: TStream); override;
  171.     procedure SaveToStream(Stream: TStream); override;
  172.     property Bitmap: TBitmap read FBitmap write SetBitmap;
  173.     property Status: TGifStatus read FStatus;
  174.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); override;
  175.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override;
  176.     property FileName: TFileName read FFileName;
  177.   published
  178.     property OnStatusChange: TStatusChangeEvent read FOnStatusChange write FOnStatusChange;
  179.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  180.     property GifVersion: TGifVersion read GetGifVersion write SetGifVersion;
  181.     property Interlaced: Boolean read GetInterlaced write SetInterlaced;
  182.     end;
  183.  
  184.   TGifImage = class(TGraphicControl)
  185.   private
  186.     FBorder: Boolean;
  187.     FOnChange: TNotifyEvent;
  188.     FFilename: TFilename;
  189.     FGif: TGif;
  190.     FOnStatusChange: TStatusChangeEvent;
  191.     function GetFilename: TFilename;
  192.     procedure SetFilename(newValue: TFilename);
  193.     procedure SetGif(newValue: TGif);
  194.     procedure SetBitmap(newValue: TBitmap);
  195.     function GetBitmap: TBitmap;
  196.     function GetBorder: Boolean;
  197.     procedure SetBorder(newValue: Boolean);
  198.   protected
  199.     procedure Paint; override;
  200.     procedure TriggerStatusChangeEvent(Sender: TObject; Status: TGifStatus); virtual;
  201.     procedure TriggerChangeEvent; virtual;
  202.     procedure GifChanged(Sender: TObject);
  203.     procedure GifStatusChanged(Sender: TObject; Status: TGifStatus);
  204.   public
  205.     constructor Create(AOwner: TComponent); override;
  206.     destructor Destroy; override;
  207.     property Canvas;
  208.     property Bitmap: TBitmap read GetBitmap;
  209.   published
  210.     property Gif: TGif read FGif write SetGif;
  211.     property Align;
  212.     property Color;
  213.     property DragCursor;
  214.     property DragMode;
  215.     property Enabled;
  216.     property ParentColor;
  217.     property ParentShowHint;
  218.     property PopupMenu;
  219.     property ShowHint;
  220.     property Visible;
  221.     property OnClick;
  222.     property OnDblClick;
  223.     property OnDragDrop;
  224.     property OnDragOver;
  225.     property OnEndDrag;
  226.     property OnMouseDown;
  227.     property OnMouseMove;
  228.     property OnMouseUp;
  229.     property OnStatusChange: TStatusChangeEvent read FOnStatusChange write FOnStatusChange;
  230.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  231.     property Border: Boolean read GetBorder write SetBorder default True;
  232.   end;
  233.  
  234.     EGifException = class(Exception);
  235.  
  236. procedure Register;
  237.  
  238. implementation
  239.  
  240. uses
  241.   ClipBrd;
  242.  
  243. function TGifImage.GetBorder: Boolean;
  244. begin
  245.   Result := FBorder;
  246. end;  { GetBorder }
  247.  
  248. procedure TGifImage.SetBorder(NewValue: Boolean);
  249. begin
  250.   if FBorder <> NewValue then
  251.   begin
  252.     FBorder := NewValue;
  253.     Repaint;
  254.   end;
  255. end;  { SetBorder }
  256.  
  257.  
  258. { General Purpose Functions }
  259.  
  260. function Power(A, N: Real): Real;
  261. { Returns A raised to the power of N }
  262. begin
  263.   Result := Exp(N * Ln(A));
  264. end;
  265.  
  266. { TGifImage }
  267.  
  268. procedure TGifImage.GifStatusChanged(Sender: TObject; Status: TGifStatus);
  269. begin
  270.   if Assigned(FOnStatusChange) then
  271.     FOnStatusChange(Self, Status);
  272. end;  { GifStatusChanged }
  273.  
  274. procedure TGifImage.GifChanged(Sender: TObject);
  275. begin
  276.   Repaint;
  277.   TriggerChangeEvent;
  278. end;  { GifChanged }
  279.  
  280. procedure TGifImage.TriggerChangeEvent;
  281. begin
  282.   if Assigned(FOnChange) then
  283.     FOnChange(Self);
  284. end;  { TriggerChangeEvent }
  285.  
  286. function TGifImage.GetFilename: TFilename;
  287. begin
  288.   Result := FFilename;
  289. end;  {GetFilename}
  290.  
  291. procedure TGifImage.SetFilename(NewValue: TFilename);
  292. begin
  293.   if FFilename <> NewValue then
  294.   begin
  295.     FFilename := NewValue;
  296.     FGif.LoadFromFile(FFilename);
  297.     Repaint;
  298.   end;
  299. end;  {SetFilename}
  300.  
  301. procedure TGifImage.SetGif(NewValue: TGif);
  302. begin
  303.   FGif.Assign(NewValue);
  304.   Repaint;
  305. end;  {SetGif}
  306.  
  307. procedure TGifImage.SetBitmap(newValue: TBitmap);
  308. begin
  309. end;  {SetBitmap}
  310.  
  311. function TGifImage.GetBitmap: TBitmap;
  312. begin
  313.   if Assigned(FGif.FBitmap) and (not FGif.FBitmap.Empty) then
  314.     Result := FGif.FBitmap
  315.   else
  316.     Result := nil;
  317. end;
  318.  
  319. procedure TGifImage.Paint;
  320. var
  321.   Dest: TRect;
  322.   AColor: TColor;
  323.   Offset: Word;
  324. begin
  325.   AColor := Color;
  326.   with inherited Canvas do
  327.   begin
  328.     Pen.Color := clBlack;
  329.     if FBorder then
  330.       Pen.Style := psSolid
  331.     else
  332.       Pen.Style := psClear;
  333.     Brush.Style := bsSolid;
  334.     Brush.Color := AColor;
  335.     Rectangle(0, 0, Width, Height);
  336.   end;
  337.   WordBool(Offset) := FBorder;
  338.   Dest := Rect(Offset, Offset, FGif.FBitmap.Width + Offset, FGif.FBitmap.Height + Offset);
  339.   with inherited Canvas do
  340.     StretchDraw(Dest, FGif.FBitmap);
  341. end;
  342.  
  343. procedure TGifImage.TriggerStatusChangeEvent(Sender: TObject; Status: TGifStatus);
  344. begin
  345.   if Assigned(FOnStatusChange) then
  346.     FOnStatusChange(Self, Status);
  347. end;  {TriggerStatusChangeEvent}
  348.  
  349. constructor TGifImage.Create(AOwner:TComponent);
  350. begin
  351.   Color := clWindow;
  352.   inherited Create(AOwner);
  353.   FGif := TGif.Create;
  354.   with FGif do
  355.   begin
  356.     OnChange := GifChanged;
  357.     OnStatusChange := GifStatusChanged;
  358.   end;
  359.   Height := 105;
  360.   Width := 105;
  361.   FBorder := True;
  362. end;
  363.  
  364. destructor TGifImage.Destroy;
  365. begin
  366.   FGif.Free;
  367.   inherited Destroy;
  368. end;
  369.  
  370. { TGif }
  371.  
  372. type
  373.     PBitmapLineStruct = ^TBitmapLineStruct;
  374.     TBitmapLineStruct = record
  375.         LineData: TGraphicLine;
  376.         LineNo: Integer;
  377.     end;
  378.  
  379. const
  380. { General Purpose Constants }
  381.     BlockTerminator: Byte = 0;              { terminates stream of data blocks }
  382.     Trailer: Byte = $3B;                          { indicates the end of the GIF data stream }
  383.   ExtensionIntroducer: Byte = $21;
  384.   ImageSeparator: Byte = $2C;
  385.  
  386. { Image Descriptor Bit Masks }
  387.     idLocalColorTable = $80;                  { set if a local color table follows }
  388.     idInterlaced = $40;                            { set if image is interlaced }
  389.     idSort = $20;                                      { set if color table is sorted }
  390.     idReserved = $0C;                                { reserved - must be set to $00 }
  391.     idColorTableSize = $07;                      { size of color table as above }
  392.  
  393. { Logical Screen Descriptor Packed Field Masks }
  394.     lsdGlobalColorTable = $80;                { set if global color table follows L.S.D. }
  395.     lsdColorResolution = $70;                  { Color resolution - 3 bits }
  396.     lsdSort = $08;                                    { set if global color table is sorted - 1 bit }
  397.     lsdColorTableSize = $07;                  { size of global color table - 3 bits }
  398.                                                               { Actual size = 2^value+1    - value is 3 bits }
  399. { Error Constants }
  400.     ErrNoError = '';                                    { No errors found }
  401.     ErrFileNotFound = 'GIF file was not found';         { Gif file not found }
  402.     ErrNotGIF = 'Invalid GIF file format';               { File is not a gif file }
  403.     ErrNoGlobalColor = 'GIF color table not found';     { No Global Color table found }
  404.     ErrImagePreceded = 'Bad GIF image data';             { image descriptor preceeded by other unknown data }
  405.     ErrEmptyBlock = 'GIF image has no data';               { Block has no data }
  406.      ErrUnExpectedEOF = 'Unexpected end of GIF file';    { unexpected EOF }
  407.     ErrBadCodeSize = 'Bad GIF code size';               { bad code size }
  408.     ErrBadCode = 'Bad GIF code';                             { Bad code was found }
  409.     ErrBitSizeOverflow = 'Bad GIF bit size';            { bit size went beyond 12 bits }
  410.   ErrNoBMP = 'GIF is empty';                                 { Could not make BMP file }
  411.  
  412. { Bit masks for use with NextCode }
  413. CodeMask: array[0..12] of Integer = ($0000, $0001, $0003, $0007, $000F, $001F, $003F,
  414.                                      $007F, $00FF, $01FF, $03FF, $07FF, $0FFF);
  415.  
  416. function TGif.GetGifVersion: TGifVersion;
  417. begin
  418.   case Ord(Header.Version[1]) of
  419.     55: FGifVersion := v87a;
  420.     57: FGifVersion := v89a;
  421.   end;
  422.   Result := FGifVersion;
  423. end;  { GetGifVersion }
  424.  
  425. procedure TGif.SetGifVersion(newValue: TGifVersion);
  426. begin
  427. (*
  428.   if FGifVersion <> newValue then
  429.   begin
  430.     FGifVersion := newValue;
  431.   end;
  432. *)
  433. end;  { SetGifVersion }
  434.  
  435. function TGif.GetInterlaced: Boolean;
  436. begin
  437.   Result := FInterlaced;
  438. end;  { GetInterlaced }
  439.  
  440. procedure TGif.SetInterlaced(newValue: Boolean);
  441. begin
  442. (*
  443.   if FInterlaced <> NewValue then
  444.   begin
  445.     FInterlaced := NewValue;
  446.   end;
  447. *)
  448. end;  { SetInterlaced }
  449.  
  450. procedure TGif.TriggerChangeEvent;
  451. begin
  452.   if Assigned(FOnChange) then
  453.     FOnChange(Self);
  454. end;  {TriggerChangeEvent}
  455.  
  456. procedure TGif.SetBitmap(NewValue: TBitmap);
  457. begin
  458.   if FBitmap <> NewValue then
  459.   begin
  460.     FBitmap.Assign(NewValue);
  461.   end;
  462. end;  {SetBitmap}
  463.  
  464. procedure TGif.Draw(ACanvas: TCanvas; const Rect: TRect);
  465. begin
  466.   StretchBlt(ACanvas.Handle, Rect.Left, Rect.Top, Rect.Right - Rect.Left,
  467.       Rect.Bottom - Rect.Top, FBitmap.Canvas.Handle, 0, 0, Width, Height, ACanvas.CopyMode);
  468. end;  {Draw}
  469.  
  470. function TGif.GetEmpty: Boolean;
  471. begin
  472.   Result := FBitmap.Empty;
  473. end;  {GetEmpty}
  474.  
  475. function TGif.GetHeight: Integer;
  476. begin
  477.   Result := ImageDescriptor.ImageHeight;
  478. end;  {GetHeight}
  479.  
  480. function TGif.GetWidth: Integer;
  481. begin
  482.   Result := ImageDescriptor.ImageWidth;
  483. end;  {GetWidth}
  484.  
  485. procedure TGif.ReadData(Stream: TStream);
  486. begin
  487.   inherited ReadData(Stream);
  488. end;  {ReadData}
  489.  
  490. procedure TGif.SetHeight(Value: Integer);
  491. begin
  492. {  TriggerChangeEvent;}
  493. end;  {SetHeight}
  494.  
  495. procedure TGif.SetWidth(Value: Integer);
  496. begin
  497. {  TriggerChangeEvent;}
  498. end;  {SetWidth}
  499.  
  500. procedure TGif.WriteData(Stream: TStream);
  501. begin
  502.   inherited WriteData(Stream);
  503. end;  {WriteData}
  504.  
  505. procedure TGif.Assign(Source: TPersistent);
  506. begin
  507.   inherited Assign(Source);
  508. end;  {Assign}
  509.  
  510. procedure TGif.LoadFromFile(const Filename: string);
  511. begin
  512.   if FFilename <> FileName then
  513.   begin
  514.     FFileName := FileName;
  515.     if (UpperCase(ExtractFileExt(FFilename)) = '.GIF') and FileExists(FFilename) then
  516.     begin
  517.       GifStream.LoadFromFile(FFilename);             { Load the file into memory }
  518.       GifDecode;
  519.     end;
  520.     TriggerChangeEvent;
  521.   end;
  522. end;  {LoadFromFile}
  523.  
  524. procedure TGif.SaveToFile(const Filename: string);
  525. begin
  526. (*
  527.   if UpperCase(ExtractFileExt(Filename)) = '.BMP' then
  528.   begin
  529.     WriteStream;
  530.     BmpStream.SaveToFile(Filename);
  531.   end
  532.   else
  533. {    Error}
  534. *)
  535. end;  {SaveToFile}
  536.  
  537. procedure TGif.LoadFromStream(Stream: TStream);
  538. begin
  539.   if Assigned(Stream) then
  540.   begin
  541.     GifStream.LoadFromStream(Stream);
  542.     GifDecode;
  543.   end;
  544.   TriggerChangeEvent;
  545. end;  {LoadFromStream}
  546.  
  547. procedure TGif.SaveToStream(Stream: TStream);
  548. var
  549.   MemStream: TMemoryStream;
  550. begin
  551.   if Assigned(Stream) then
  552.   begin
  553.     MemStream := TMemoryStream.Create;
  554.     WriteStream;
  555.     MemStream.LoadFromStream(BmpStream);
  556.     MemStream.SaveToStream(Stream);
  557.     MemStream.Free;
  558.   end;
  559. end;  {SaveToStream}
  560.  
  561. destructor TGif.Destroy;
  562. begin
  563.   if Assigned(FBitmap) then FBitmap.Free;
  564.   if Assigned(GifStream) then GifStream.Free;
  565.   if Assigned(BmpStream) then BmpStream.Free;
  566.   if Assigned(ImageLines) then ImageLines.Free;
  567.   inherited Destroy;
  568. end;  {Destroy}
  569.  
  570. constructor TGif.Create;
  571. begin
  572.   inherited Create;
  573.   FBitmap := TBitmap.Create;
  574.   GifStream := TMemoryStream.Create;
  575.   BmpStream := TMemoryStream.Create;
  576.   ImageLines := TList.Create;
  577.   FStatus := 0;
  578.   FFileName := '';
  579. end;  {Create}
  580.  
  581. procedure TGif.GifDecode;
  582.  
  583.   {------------------------------------------------------------------------------}
  584.  
  585.   procedure CreateBitHeader;
  586.   { This routine takes the values from the GIF
  587.     image descriptor and fills in the appropriate
  588.     values in the bitmap header struct }
  589.   begin
  590.     BmHeader.biSize := SizeOf(TBitmapInfoHeader);
  591.     BmHeader.biWidth := ImageDescriptor.ImageWidth;
  592.     BmHeader.biHeight := ImageDescriptor.ImageHeight;
  593.     BmHeader.biPlanes := 1;                           { Arcane and rarely used }
  594.     BmHeader.biBitCount := 8;                         { Should this be hardcoded? }
  595.     BmHeader.biCompression := BI_RGB;                 { No compression in this version }
  596.     BmHeader.biSizeImage := 0;                        { Because we are not compressing image }
  597.     BmHeader.biXPelsPerMeter :=143;                   { Rarely used very arcane field }
  598.     BmHeader.biYPelsPerMeter :=143;                   { Rarely used very arcane field }
  599.     BmHeader.biClrUsed := 0;                          { all colors are used }
  600.     BmHeader.biClrImportant := 0;                     { all colors are important }
  601.   end;
  602.  
  603.   {------------------------------------------------------------------------------}
  604.  
  605. begin
  606.   ParseMem;
  607.   { Create the bitmap header info }
  608.   MaxStatus := (ImageDescriptor.ImageHeight * 2);
  609.   ChangeStatus(0);
  610.   CreateBitHeader;
  611.   { Decode the GIF }
  612.   Decode;
  613.   WriteStream;
  614. end;
  615.  
  616. procedure TGif.Decode;
  617.  
  618.   {------------------------------------------------------------------------------}
  619.  
  620.   var
  621.     SP: Integer;
  622.  
  623.   procedure DecodeCode(var Code: Word);           { Local procedure that decodes a }
  624.   begin                                             { code and puts it on the decode stack }
  625.     while Code > HighCode do                      { rip thru the prefix list placing suffixes }
  626.     begin                                         { onto the decode stack }
  627.       DecodeStack[SP] := Suffix[Code];            { put the suffix on the decode stack }
  628.       inc(SP);                                    { increment decode stack index }
  629.       Code := Prefix[Code];                       { get the new prefix }
  630.     end;
  631.     DecodeStack[SP] := Code;                        { put the last code onto the decode stack }
  632.     inc(SP);                                            { increment the decode stack index }
  633.   end; { DecodeCode }
  634.  
  635.   {------------------------------------------------------------------------------}
  636.  
  637.   procedure InitCompressionStream;
  638.   begin
  639.     GifStream.Read(LZWCodeSize, SizeOf(Byte));      { get minimum code size }
  640.     if not (LZWCodeSize in [2..9]) then             { valid code sizes 2-9 bits }
  641.        GifError(ErrBadCodeSize);
  642.     CurrCodeSize := succ(LZWCodeSize);            { set the initial code size }
  643.     ClearCode := 1 shl LZWCodeSize;               { set the clear code }
  644.     EndingCode := succ(ClearCode);                { set the ending code }
  645.     HighCode := pred(ClearCode);                       { set the highest code not needing decoding }
  646.     BytesLeft := 0;                               { clear other variables }
  647.     BitsLeft := 0;
  648.     CurrentX := 0;
  649.     CurrentY := 0;
  650.   end; { InitCompressionStream }
  651.  
  652.   {------------------------------------------------------------------------------}
  653.  
  654.   procedure ReadSubBlock;
  655.   begin
  656.     GifStream.Read(ImageData.Size, SizeOf(ImageData.Size));   { get the data block size }
  657.     if ImageData.Size = 0 then
  658.       GifError(ErrEmptyBlock);                                                  { check for empty block }
  659.     GifStream.Read(ImageData.Data, ImageData.Size);             { read in the block }
  660.     NextByte := 1;                                            { reset next Byte }
  661.     BytesLeft := ImageData.Size;                                      { reset Bytes left }
  662.   end; { ReadSubBlock }
  663.  
  664.   {------------------------------------------------------------------------------}
  665.  
  666.   function NextCode: Word;                        { returns a code of the proper bit size }
  667.   begin
  668.     if BitsLeft = 0 then                            { any bits left in Byte ? }
  669.     begin                                                     { any Bytes left }
  670.       if BytesLeft <= 0 then                         { if not get another block }
  671.         ReadSubBlock;
  672.       CurrByte := ImageData.Data[NextByte];         { get a Byte }
  673.       inc(NextByte);                                { set the next Byte index }
  674.       BitsLeft := 8;                                { set bits left in the Byte }
  675.       dec(BytesLeft);                               { decrement the Bytes left counter }
  676.     end;
  677.     Result := CurrByte shr (8 - BitsLeft);              { shift off any previosly used bits}
  678.     while CurrCodeSize > BitsLeft do                { need more bits ? }
  679.     begin
  680.       if BytesLeft <= 0 then                                  { any Bytes left in block ? }
  681.         ReadSubBlock;                             { if not read in another block }
  682.       CurrByte := ImageData.Data[NextByte];          { get another Byte }
  683.       inc(NextByte);                                 { increment NextByte counter }
  684.       Result := Result or
  685.           (CurrByte shl BitsLeft);                  { add the remaining bits to the return value }
  686.       BitsLeft := BitsLeft + 8;                   { set bit counter }
  687.       Dec(BytesLeft);                               { decrement Bytesleft counter }
  688.     end;
  689.     BitsLeft := BitsLeft - CurrCodeSize;          { subtract the code size from bitsleft }
  690.     Result := Result and CodeMask[CurrCodeSize];  { mask off the right number of bits }
  691.   end; { NextCode }
  692.  
  693.   {------------------------------------------------------------------------------}
  694.  
  695.   procedure CreateLine;
  696.   {fills in Line list with current line}
  697.   var
  698.     p: PBitmapLineStruct;
  699.   begin
  700.     Application.ProcessMessages;
  701.     New(p);                                       {Create a new bmp line}
  702.     p^.LineData := LineBuffer;                    {Fill in the data}
  703.     p^.LineNo := CurrentY;
  704.     ImageLines.Add(p);                            { Add it to the list of lines }
  705.     Inc(CurrentY);                                { Prepare for the next line }
  706.     ChangeStatus(CurStatus + 1);
  707.     if FInterlaced then                            { Interlace support }
  708.     begin
  709.       case InterlacePass of
  710.         0: CurrentY := CurrentY + 7;
  711.         1: CurrentY := CurrentY + 7;
  712.         2: CurrentY := CurrentY + 3;
  713.         3: CurrentY := CurrentY + 1;
  714.         end;
  715.       if CurrentY >= ImageDescriptor.ImageHeight then
  716.       begin
  717.         Inc(InterLacePass);
  718.         case InterLacePass of
  719.           1: CurrentY := 4;
  720.           2: CurrentY := 2;
  721.           3: CurrentY := 1;
  722.         end;
  723.       end;
  724.     end;
  725.   end; { CreateLine }
  726.  
  727.   {------------------------------------------------------------------------------}
  728.  
  729. var
  730.     TempOldCode, OldCode: Word;
  731.     BufCnt: Word;                      { line buffer counter }
  732.     Code, C: Word;
  733.     CurrBuf: Word;                    { line buffer index }
  734.   MaxVal: Boolean;
  735. begin
  736.   InitCompressionStream;                          { Initialize decoding paramaters }
  737.   OldCode := 0;
  738.   SP := 0;
  739.   BufCnt := ImageDescriptor.ImageWidth;           { set the Image Width }
  740.   CurrBuf := 0;
  741.   MaxVal := False;
  742.   C := NextCode;                                          { get initial code - should be clear code }
  743.   while C <> EndingCode do                        { main loop until ending code is found }
  744.   begin
  745.     if C = ClearCode then                            { code is clear code - so clear }
  746.     begin
  747.       CurrCodeSize := LZWCodeSize + 1;              { reset the code size }
  748.       Slot := EndingCode + 1;                              { set slot for next new code }
  749.       TopSlot := 1 shl CurrCodeSize;                { set max slot number }
  750.       while C = ClearCode do
  751.         C := NextCode;                              { read until all clear codes gone }
  752.       if C = EndingCode then
  753.         GifError(ErrBadCode);                       { ending code after a clear code }
  754.       if C >= Slot then                           { if beyond preset codes then set to zero }
  755.         C := 0;
  756.       OldCode := C;
  757.       DecodeStack[sp] := C;                         { output code to decoded stack }
  758.       inc(SP);                                          { increment decode stack index }
  759.     end
  760.     else                                          { not  clear code or ending code so must }
  761.     begin                                         { be a code code - so decode the code }
  762.       Code := C;
  763.       if Code < Slot then                         { is the code in the table? }
  764.       begin
  765.         DecodeCode(Code);                         { decode the code }
  766.         if Slot <= TopSlot then
  767.         begin                                           { add the new code to the table }
  768.           Suffix[Slot] := Code;                        { make the suffix }
  769.           PreFix[slot] := OldCode;                   { the previous code - a link to the data }
  770.           inc(Slot);                                 { increment slot number }
  771.           OldCode := C;                              { set oldcode }
  772.         end;
  773.         if Slot >= TopSlot then                       { have reached the top slot for bit size }
  774.         begin                                       { increment code bit size }
  775.           if CurrCodeSize < 12 then                 { new bit size not too big? }
  776.           begin
  777.             TopSlot := TopSlot shl 1;                { new top slot }
  778.             inc(CurrCodeSize)                           { new code size }
  779.           end
  780.           else
  781.             MaxVal := True;                             { Must check next code is a start code }
  782.         end;
  783.       end
  784.       else
  785.       begin                                          { the code is not in the table }
  786.         if Code <> Slot then
  787.           GifError(ErrBadCode);                   { so error out }
  788.         { code does not exist, so make
  789.           a new entry in the code table
  790.           and then translate the new code }
  791.         TempOldCode := OldCode;                   { make a copy of the old code }
  792.         while OldCode > HighCode do                 { translate the old code and place it }
  793.         begin                                            { on the decode stack }
  794.           DecodeStack[SP] := Suffix[OldCode];     { do the suffix }
  795.           OldCode := Prefix[OldCode];             { get next prefix }
  796.         end;
  797.         DecodeStack[SP] := OldCode;                  { put the code onto the decode stack
  798.                                                     but DO NOT increment stack index }
  799.         { the decode stack is not
  800.           incremented because because
  801.           we are only translating the oldcode
  802.           to get the first Character }
  803.         if Slot <= TopSlot then
  804.         begin                                       { make new code entry }
  805.           Suffix[Slot] := OldCode;                   { first Char of old code }
  806.           Prefix[Slot] := TempOldCode;               { link to the old code prefix }
  807.           inc(Slot);                                 { increment slot }
  808.         end;
  809.         if Slot >= TopSlot then                   { slot is too big }
  810.         begin                                                  { increment code size }
  811.           if CurrCodeSize < 12 then
  812.           begin
  813.             TopSlot := TopSlot shl 1;                { new top slot }
  814.                 inc(CurrCodeSize);                   { new code size }
  815.           end
  816.           else
  817.               MaxVal := True;                           { Must check next code is a start code }
  818.         end;
  819.         DecodeCode(Code);                         { now that the table entry exists decode it }
  820.         OldCode := C;                             { set the new old code }
  821.       end;
  822.     end;
  823.     { the decoded string is on the decode
  824.       stack so pop it off and put it into
  825.       the line buffer }
  826.     while SP > 0 do
  827.     begin
  828.       dec(SP);
  829.       LineBuffer[CurrBuf] := DecodeStack[SP];
  830.       inc(CurrBuf);
  831.       dec(BufCnt);
  832.       if BufCnt = 0 then                          { is the line full ? }
  833.       begin
  834.         CreateLine;
  835.         CurrBuf := 0;
  836.         BufCnt := ImageDescriptor.ImageWidth;
  837.       end;
  838.     end;
  839.     C := NextCode;                                  { get the next code and go at is some more }
  840.     if (MaxVal = True) and (C <> ClearCode) then
  841.       GifError(ErrBitSizeOverflow);
  842.     MaxVal := False;
  843.   end;
  844. end; { GifDecode }
  845.  
  846. procedure TGif.WriteStream;
  847. var
  848.   BitFile: TBitmapFileHeader;
  849.   i,
  850.   Line,
  851.   x: Integer;
  852.   Ch: Char;
  853.   p: PBitmapLineStruct;
  854. begin
  855.   BitFile.bfSize := (3 * 255) + SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader) +
  856.       (ImageDescriptor.ImageHeight * ImageDescriptor.ImageWidth);
  857.   BitFile.bfReserved1 := 0;                       { Not currently used }
  858.   BitFile.bfReserved2 := 0;                       { Not currently used }
  859.   BitFile.bfOffBits := (4 * 256) + SizeOf(TBitmapFileHeader) + SizeOf(TBitmapInfoHeader);
  860.   BmpStream.Clear;                                { Write the file header }
  861. {  BmpStream.Seek(0,0);}
  862.   Ch := 'B';
  863.   BmpStream.Write(Ch, 1);
  864.   Ch := 'M';
  865.   BmpStream.Write(Ch, 1);
  866.   BmpStream.Write(BitFile.bfSize, SizeOf(BitFile.bfSize));
  867.   BmpStream.Write(BitFile.bfReserved1, SizeOf(BitFile.bfReserved1));
  868.   BmpStream.Write(BitFile.bfReserved2, SizeOf(BitFile.bfReserved2));
  869.   BmpStream.Write(BitFile.bfOffBits, SizeOf(BitFile.bfOffBits));
  870.   BmpStream.Write(BmHeader, SizeOf(BmHeader));    { Write the bitmap image header info }
  871.   { Write the RGB palete
  872.     inforamtion to this file }
  873.   if UseLocalColors then                          { Use the local color table }
  874.   begin
  875.     for i:= 0 to 255 do
  876.     begin
  877.       BmpStream.Write(LocalColorTable[i].Blue, 1);
  878.       BmpStream.Write(LocalColorTable[i].Green, 1);
  879.       BmpStream.Write(LocalColorTable[i].Red, 1);
  880.       BmpStream.Write(Ch, 1);                     { Bogus palete entry required by windows }
  881.     end;
  882.   end
  883.   else                                            { Use the global table }
  884.   begin
  885.     for i:= 0 to 255 do
  886.     begin
  887.       BmpStream.Write(GlobalColorTable[i].Blue, 1);
  888.       BmpStream.Write(GlobalColorTable[i].Green, 1);
  889.       BmpStream.Write(GlobalColorTable[i].Red, 1);
  890.       BmpStream.Write(Ch, 1);                     { Bogus palete entry required by windows }
  891.     end;
  892.   end;
  893.   Line := ImageDescriptor.ImageHeight;            { Init the Line Counter }
  894.   {Write out File lines in reverse order}
  895.   while Line >= 0 do
  896.   begin
  897.     { Go through the line list in reverse
  898.       order looking for the current Line.
  899.       Use reverse order since non interlaced
  900.       gifs are stored top to bottom.  Bmp file
  901.       needs to be written bottom to top }
  902.     for i := (ImageLines.Count - 1) downto 0  do
  903.     begin
  904.       ChangeStatus(CurStatus + 1);
  905.       p := ImageLines.Items[i];
  906.       if p^.LineNo = Line then
  907.       begin
  908.         x := ImageDescriptor.ImageWidth;
  909.         BmpStream.Write(p^.LineData, x);
  910.         Ch := chr(0);
  911.         while (x and 3) <> 0 do                   { Pad up to 4-Byte boundary with zeroes }
  912.         begin
  913.           Inc(x);
  914.           BmpStream.Write(Ch, 1);
  915.         end;
  916.         Break;
  917.       end;
  918.     end;
  919.     Dec(Line);
  920.   end;
  921.   BmpStream.Seek(0, 0);                           { Reset mewmory stream}
  922.   FBitmap.LoadFromStream(BmpStream);
  923.   ChangeStatus(0);
  924. end; { WriteStream }
  925.  
  926. procedure TGif.ParseMem;
  927. { Decodes the header and palette info }
  928. begin
  929.   GifStream.Read(Header, SizeOf(Header));                     { read the header }
  930.   if Header.Signature <> 'GIF' then
  931.     GifError(ErrNotGif);                                          { is vaild signature? }
  932.   GifStream.Read(LogicalScreen, SizeOf(LogicalScreen));       { Decode header information }
  933.   if LogicalScreen.PackedFields and lsdGlobalColorTable = lsdGlobalColorTable then
  934.   begin
  935.     TableSize := Trunc(Power(2, (LogicalScreen.PackedFields and lsdColorTableSize) + 1));
  936.     { Read Global Color Table }
  937.     GifStream.Read(GlobalColorTable, TableSize * SizeOf(TColorItem));
  938.   end
  939.   else
  940.     GifError(ErrNoGlobalColor);
  941.   GifStream.Read(ImageDescriptor, SizeOf(ImageDescriptor));   { Read image descriptor }
  942.   if ImageDescriptor.Separator <> ImageSeparator then         { Verify the descriptor }
  943.     GifError(ErrImagePreceded);
  944.   { Check for local color table }
  945.   if ImageDescriptor.PackedFields and idLocalColorTable = idLocalColorTable then
  946.   begin
  947.     TableSize := Trunc(Power(2, (ImageDescriptor.PackedFields and idColorTableSize) + 1));
  948.     { Read Local Color Table }
  949.     GifStream.Read(LocalColorTable, TableSize * SizeOf(TColorItem));
  950.     UseLocalColors := True;
  951.   end
  952.   else
  953.     UseLocalColors := False;
  954.   {Check for interlaced}
  955.   FInterlaced := ImageDescriptor.PackedFields and idInterlaced = idInterlaced;
  956.   if FInterlaced then
  957.     InterlacePass := 0;
  958.   { Reset then Expand capacity of the Image Lines list }
  959.   ImageLines.Clear;
  960.   ImageLines.Capacity := ImageDescriptor.ImageHeight;
  961.   if (GifStream = nil) then
  962.     GifError(ErrFileNotFound);
  963. end; { ParseMem }
  964.  
  965. procedure TGif.ChangeStatus(LoadStatus: LongInt);
  966. begin
  967.   if LoadStatus > MaxStatus then
  968.   begin
  969.     FStatus := 100;
  970.     CurStatus := MaxStatus;
  971.   end
  972.   else
  973.   begin
  974.     FStatus := Round((LoadStatus / MaxStatus) * 100);
  975.     CurStatus := LoadStatus;
  976.   end;
  977.   if Assigned(FOnStatusChange) then
  978.     FOnStatusChange(Self, FStatus);
  979. end;  {TriggerStatusChangeEvent}
  980.  
  981. {Raise exception with a message}
  982. procedure TGif.GifError(ErrorStr: String);
  983. begin
  984.   if ErrorStr > ' ' then
  985.     raise EGifException.Create(ErrorStr);
  986. end;
  987.  
  988. procedure TGif.SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE);
  989. begin
  990. end;  { SaveToClipboardFormat }
  991.  
  992. procedure TGif.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE);
  993. begin
  994. end;  { LoadFromClipboardFormat }
  995.  
  996. procedure Register;
  997. begin
  998. end;  {Register}
  999.  
  1000. end.
  1001.  
  1002.